Optional images.f

{ Relies on SDL and Seki.

TODO:

resize-image

}

Requires OpenGL
Requires SDL
Requires Kagi
Requires Tools
Requires Seki
Requires Vectors
Requires SORA\Surfaces
Requires DevIL

Only Forth Definitions


Struct
   cell field ->source-image     \ file in memory
   cell field ->texture
   cell field ->texture-x
   cell field ->texture-y
   cell field ->subimages
   cell field ->subimages-count
   /Surface field ->surface
End-struct /Image

: Graphic:  ( filename count -- <name> )
   here >r cache-file,
   Create r> , 0 , 0 , 0 , 0 , 0 , /Surface /allot ;

: blank-image,   ( w h -- )
   0 , 0 , 0 , 0 , 0 , 0 , blank-surface, ;

\ Creates a temporary DevIL image, deleting it after the quotation is finished.
:[] il:[   ( xt -- ) ( il-image -- )
   ilInit ilGenImage dup >q ilBindImage catch q> ilDeleteImage throw ilShutDown ;

: il-dims   IL_IMAGE_WIDTH ilGetInteger IL_IMAGE_HEIGHT ilGetInteger ;

: surface>il  ( surface -- success? )
   dup >r sdl-dims 1 4 IL_BGRA IL_UNSIGNED_BYTE  r> 0 0 sdl-pixel ilTexImage ;

: sdl-ilformat
   dup sdl-has-alpha? IF
      sdl-red-first? IF IL_RGBA ELSE IL_BGRA THEN
   ELSE
      sdl-red-first? IF IL_RGB ELSE IL_BGR THEN
   THEN ;

: Palette:
   Create 256 0 do $deadbeef , loop ;

-? 0 value S

: (il-load-lump)
   2dup 2>r ilDetermineTypeL 2r> ilLoadL 0= abort" Error loading image from memory. (DevIL)" ;

: (il-create-surface)
   IL_PAL_RGBA32 ilConvertPal 0= abort" Error converting palette. (DevIL)"
   il-dims sdl-new to S
   ilCopyPixels(  0  0  0  il-dims   1  IL_BGRA  IL_UNSIGNED_BYTE  S 0 0 sdl-pixel ) drop ;

: image-load-surface&palette ( image palette -- )
   swap ->source-image @ ?dup if
      cache-count locals| size lump palette |
      il:[
         lump size (il-load-lump) (il-create-surface)
         ilGetPalette  palette  IL_PALETTE_SIZE ilGetInteger cells  move
      ;]
      S prepare-surface
   then drop ;

: image-load-surface ( image -- sdl-surface | 0 )
   ->source-image @ ?dup if
      cache-count locals| size lump |
      il:[
         lump size (il-load-lump) (il-create-surface)
      ;]
      S prepare-surface
   else 0 then ;

: load-surface ( filename count -- surface )
   z$ locals| filename |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      (il-create-surface)
   ;] S ;

: load-surface&palette ( filename count palette -- surface )
   -rot z$ locals| filename palette |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      (il-create-surface)
      ilGetPalette  ( dup mem )  palette  256  cells  move
   ;] S ;


\ Bit-depths 8 and 32 are supported
: save-surface ( surface bitdepth filename count -- )
   z$ locals| filename bitdepth S |
   il:[
      S surface>il 0=
         abort" Error converting surface to image for saving. (DevIL)"
      bitdepth 8 = if
         ilConvertImage( IL_COLOR_INDEX IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
         ilConvertPal( IL_PAL_RGBA32 )
            0= abort" Error converting palette. (DevIL)"
      else ilConvertImage( IL_RGBA IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
      then
      ilHint( IL_USE_COMPRESSION IL_COMPRESSION_HINT )
      \ Not sure if this is always needed, but so far BMP, PNG, and JPG all required it... maybe it's something else that I'm doing????
         iluFlipImage
      filename zcount delete-file drop
      filename ilSaveImage
         0= abort" Error saving image. Maybe the file is locked. (DevIL)"
   ;] ;

: init-image ( image -- )
   dup  image-load-surface  swap  ->surface build:[  surface,  ;] ;

: save-palette ( palette filename count -- )
   rot locals| palette |
   file:[  empty-file  palette  256 cells  rot  write-file  throw  ;] ;

: load-palette ( filename count palette -- )
   -rot  file:[  read-file  throw  drop  ;]  ;

\ Subimages format:
\  x , y , w , h , origin-x , origin-y , x-stride (for fonts) , char# (for fonts) , (all 16bit signed half's)
\                                        delay (for sprites) , jump (for sprites)
16 constant /Subimage

: Subimages:  ( image -- )
   here  swap  ->subimages  !  ;

: subimage[]  ( subimages  n -- addr )
   /Subimage  *  +  ;

: image@surface  ( image -- sdl-surface )
   ->surface  surface@  ;

: image@dims ( image -- w h )   image@surface sdl-dims ;
: image@width  image@dims drop ;
: image@height  image@dims nip ;

: image-load-texture
   dup init-image  \ temporary
   \ dup image@surface 0= if dup init-image then
   dup image@surface sdl-texture swap ->texture ! ;

\ Subimage properties
:macro @origin   8 + 2h@ ;

\ For font symbols
:macro @xstride   12 + h@ ;

\ For sprites
:macro @delay  12 + h@ ;
:macro @next-frame  14 + h@ ;


\ Defines how much 1 (integer) equals when using 16bit signed texture coordinates.
\  It's OK to use either fixed point or integers here, so long as the numbers are all the same type.
: texture-granularity  ( granx grany texw texh -- )
   tm-identity   swap  glscaled(  1e .>f f/ swap .>f f*   1e .>f f/ .>f f*   1e ) ;

: bind-image-texture  ( granx grany image -- )
   dup  ->texture  @  bind-texture   image@dims  texture-granularity ;

: bind-image  ( image -- )
   1 1 rot bind-image-texture ;
